-----------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.Keyboard
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Subscription.Keyboard
  ( -- *** Types
    Arrows (..)
    -- *** Subscriptions
  , arrowsSub
  , directionSub
  , keyboardSub
  , wasdSub
  ) where
-----------------------------------------------------------------------------
import           Control.Monad.IO.Class
import           Data.IORef
import           Data.IntSet
import qualified Data.IntSet as S
import           Language.Javascript.JSaddle hiding (new)
-----------------------------------------------------------------------------
import           Miso.Effect (Sub)
import           Miso.Subscription.Util (createSub)
import qualified Miso.FFI.Internal as FFI
-----------------------------------------------------------------------------
-- | Type for arrow keys currently pressed.
--
--  * 37 left arrow  ( x = -1 )
--  * 38 up arrow    ( y =  1 )
--  * 39 right arrow ( x =  1 )
--  * 40 down arrow  ( y = -1 )
data Arrows
 = Arrows
 { arrowX :: !Int
 , arrowY :: !Int
 } deriving (Show, Eq)
-----------------------------------------------------------------------------
-- | Helper function to convert keys currently pressed to @Arrows@, given a
-- mapping for keys representing up, down, left and right respectively.
toArrows :: ([Int], [Int], [Int], [Int]) -> IntSet -> Arrows
toArrows (up, down, left, right) set' = Arrows
  { arrowX =
      case (check left, check right) of
        (True, False) -> -1
        (False, True) -> 1
        (_,_) -> 0
  , arrowY =
      case (check down, check up) of
        (True, False) -> -1
        (False, True) -> 1
        (_,_) -> 0
  } where
      check = any (`S.member` set')
-----------------------------------------------------------------------------
-- | Maps t'Arrows' onto a Keyboard subscription.
arrowsSub :: (Arrows -> action) -> Sub action
arrowsSub = directionSub ([38], [40], [37], [39])
-----------------------------------------------------------------------------
-- | Maps t'Arrows' onto a Keyboard subscription for directions (W+A+S+D keys).
wasdSub :: (Arrows -> action) -> Sub action
wasdSub = directionSub ([87], [83], [65], [68])
-----------------------------------------------------------------------------
-- | Maps a specified list of keys to directions (up, down, left, right).
-- The Ints represent [keyCode](https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent/keyCode)s for each direction.
directionSub
  :: ([Int], [Int], [Int], [Int])
  -> (Arrows -> action)
  -> Sub action
directionSub dirs = keyboardSub . (. toArrows dirs)
-----------------------------------------------------------------------------
-- | Returns 'Sub' for keyboard events.
-- The callback will be called with the Set of currently pressed @keyCode@s.
keyboardSub :: (IntSet -> action) -> Sub action
keyboardSub f sink = createSub acquire release sink
  where
    release (cb1, cb2, cb3) = do
      FFI.windowRemoveEventListener "keyup" cb1
      FFI.windowRemoveEventListener "keydown" cb2
      FFI.windowRemoveEventListener "blur" cb3
    acquire = do
      keySetRef <- liftIO (newIORef mempty)
      cb1 <- FFI.windowAddEventListener "keyup" (keyUpCallback keySetRef)
      cb2 <- FFI.windowAddEventListener "keydown" (keyDownCallback keySetRef)
      cb3 <- FFI.windowAddEventListener "blur" (blurCallback keySetRef)
      pure (cb1, cb2, cb3)
        where
          keyDownCallback keySetRef = \keyDownEvent -> do
              key <- fromJSValUnchecked =<< getProp "keyCode" (Object keyDownEvent)
              newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys ->
                 let !new = S.insert key keys
                 in (new, new)
              sink (f newKeys)

          keyUpCallback keySetRef = \keyUpEvent -> do
              key <- fromJSValUnchecked =<< getProp "keyCode" (Object keyUpEvent)
              newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \keys ->
                 let !new = S.delete key keys
                 in (new, new)
              sink (f newKeys)

          -- Assume keys are released the moment focus is lost. Otherwise going
          -- back and forth to the app can cause keys to get stuck.
          blurCallback keySetRef = \_ -> do
              newKeys <- liftIO $ atomicModifyIORef' keySetRef $ \_ ->
                let !new = S.empty
                in (new, new)
              sink (f newKeys)
-----------------------------------------------------------------------------
